home *** CD-ROM | disk | FTP | other *** search
/ PC Graphics Unleashed / PC Graphics Unleashed.iso / ch18 / rad386 / esample.lsp < prev    next >
Lisp/Scheme  |  1993-07-15  |  26KB  |  667 lines
  1. ;;; **************************************************************************
  2. ;;;        esample.lsp
  3. ;;;
  4. ;;;        This file is part of the program torad.lsp to export
  5. ;;;        RADIANCE scene description files from Autocad.
  6. ;;;
  7. ;;;        Copyright (C) 1993 by Georg Mischler / Lehrstuhl
  8. ;;;                              fuer Bauphysik ETH Zurich.
  9. ;;; 
  10. ;;;        Permission to use, copy, modify, and distribute this software 
  11. ;;;        for any purpose and without fee is hereby granted, provided 
  12. ;;;        that the above copyright notice appears in all copies and that 
  13. ;;;        both that copyright notice and this permission notice appear in 
  14. ;;;        all supporting documentation. 
  15. ;;; 
  16. ;;;        THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED 
  17. ;;;        WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR 
  18. ;;;        PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. 
  19. ;;; 
  20. ;;;        Acknowlegdements:  
  21. ;;;        Final developement of this program has been sponsored by Prof. Dr.  
  22. ;;;        B. Keller, Building Physics, Dep. for Architekture ETH Zurich.  
  23. ;;;        The developement environment has been provided by Prof. Dr.
  24. ;;;        G. Schmitt, Architecture & CAAD ETH Zurich.
  25. ;;;
  26. ;;; **************************************************************************
  27.  
  28. ;;; VISIBLE LAYERS ***********************************************************
  29.  
  30. (defun vislaylist ( / layer laylist )
  31.   ;; generate list of layernames currently visible.
  32.   (setq layer (tblnext "LAYER" T))
  33.   (if (and (< 0 (cdr (assoc 62 layer)))
  34.           (= 0 (logand 1 (cdr (assoc 70 layer)))) )
  35.          (setq laylist (list (cdr (assoc 2 layer)))) )
  36.   (while (setq layer (tblnext "LAYER"))
  37.          (if (and (< 0 (cdr (assoc 62 layer)))
  38.                   (= 0 (logand 1 (cdr (assoc 70 layer)))) )
  39.              (setq laylist (cons (cdr (assoc 2 layer)) laylist)) ) )
  40.   laylist )
  41.  
  42.  
  43.  
  44. ;;; STORAGE INTERFACE ********************************************************
  45.  
  46. (defun valuablepoly (typ)
  47.   ;; test an entity type for compliance with setup.
  48.   (car (member typ *valuablepolylist*) ))
  49.  
  50.  
  51.  
  52. (defun makeentlist ( / num)
  53.   ;; initialize entity list and create sublists according to sampling mode.
  54.   (cond ( (= *exportsmode* "Color")
  55.           (setq num 1)
  56.           (while (> 256 num)            ; list colors instead of layers.
  57.                  (setq *exportentlist* (cons (list (itoa num)) *exportentlist*)
  58.                        num (1+ num) ) ) )
  59.         ( T
  60.           (setq *exportentlist* (mapcar 'list *exporttruelays*)) ) ) )
  61.  
  62.  
  63.  
  64. (defun addlayentlist (c-ent elay / oldlist newlist)
  65.   ;; update entity list with new element added to the correct sublist.
  66.   (setq oldlist (assoc elay *exportentlist*)
  67.         newlist (append oldlist (list c-ent))
  68.         *exportentlist* (subst newlist oldlist *exportentlist*) ) )
  69.  
  70.  
  71.  
  72. (defun addpolblocklist (blent)
  73.   ;; update blocklist with a new element.
  74.   (setq *exportblocklist* (append *exportblocklist* (list blent))) )
  75.  
  76.  
  77.  
  78. ;;; TOP LEVEL ENTITIES ****************************************************
  79.  
  80. (defun sampleents (selset / num etype c-ent c-data elay numtot numstep)
  81.   ;; extract entities out of a selection set and store to the apropriate list.
  82.   (terpri)(terpri)
  83.   (setq num 0
  84.         numtot (sslength selset)
  85.         numstep 0 )
  86.   (while (> numtot numstep)
  87.          (prompt (strcat "      sampling entities level 0:  "
  88.                          (itoa numstep) "/" (itoa numtot) "  \r"))
  89.          (setq numstep (min (+ numstep 25) numtot))
  90.          (while (< num  numstep)
  91.                 (setq c-ent (ssname selset num))
  92.                 (setq num (1+ num)
  93.                       c-data (entget c-ent)
  94.                       elay (get_laystring c-data nil)
  95.                       etype (getetype c-data) )
  96.                 (cond ( (= "INSERT" etype)
  97.                         (addpolblocklist (list c-ent)) )
  98.                       ( (and (valuablepoly etype)
  99.                              (member elay *exporttruelays*) )
  100.                         (if (equal *exportsmode* "Color")
  101.                             (addlayentlist c-ent (get_colstring c-data nil))
  102.                             (addlayentlist c-ent elay) ) )
  103.                       (T NIL) ) ) )
  104.   (prompt (strcat "      sampling entities level 0:  "
  105.                   (itoa numstep ) "       \n")) )
  106.  
  107.  
  108.  
  109.  
  110. ;;; BLOCKS ****************************************************************
  111.  
  112. (defun sampleblocks (level / num numstep numtot xdata block blockl ename)
  113.   ;; extract entities of a block stored previously on the blocks list.
  114.   ;; pass the result on for proper storage.
  115.   (setq blockl *exportblocklist*
  116.         *exportblocklist* nil
  117.         num 0
  118.         numtot (length blockl)
  119.         numstep 0 )
  120.   (while (> numtot numstep)
  121.          (prompt (strcat "        sampling blocks level " (itoa level)
  122.                          ":  " (itoa numstep) "/" (itoa numtot) "  \r"))
  123.          (setq numstep (min (+ numstep 10) numtot) )
  124.          (while (< num  numstep)
  125.                 (setq num (1+ num)
  126.                       block (car blockl)
  127.                       blockl (cdr blockl) )
  128.                 (addblockentslist block) ) )
  129.   (prompt (strcat "        sampling blocks level "
  130.                   (itoa level) ":  " (itoa numstep) "       \n")) )
  131.  
  132.  
  133.  
  134. (defun addblockentslist (bllist / blent notend data ent typ elay)
  135.   ;; store the entities out of blocklist in the correct place:
  136.   ;; - if a block back to blocklist.
  137.   ;; - if an entity on a valid layer on the entity list sorted according
  138.   ;;   to samplemode.
  139.   (setq notend T
  140.         blent (car bllist)
  141.         ent (cdr (assoc -2 (tblsearch "BLOCK" (cdr (assoc 2 (entget blent)))))) )  (while (and notend ent)
  142.          (setq data (entget ent)
  143.                typ (cdr (assoc 0 data)) )
  144.          (cond ( (= typ "INSERT")
  145.                  (addpolblocklist (cons ent bllist) ) )
  146.                ( (= typ "ENDBLK")
  147.                  (setq notend nil) )
  148.                ( (valuablepoly (getetype data))
  149.                  (setq elay (get_laystring data bllist))
  150.                  (if (member elay *exporttruelays*)
  151.                      (cond ( (equal *exportsmode* "Color")
  152.                              (addlayentlist (cons ent bllist)
  153.                                             (get_colstring data bllist) ) )
  154.                            ( (equal *exportsmode* "Toplayer")
  155.                              (addlayentlist (cons ent bllist)
  156.                                 (get_laystring (entget (if bllist
  157.                                                            (last bllist)
  158.                                                            blent ) ) NIL)) )
  159.                            ( T
  160.                              (addlayentlist (cons ent bllist) elay) ) ) )   )
  161.                ( T NIL) )
  162.          (setq ent (entnext ent)) )
  163.   NIL )
  164.  
  165.  
  166.  
  167. ;;; ***************************************************
  168.  
  169. (defun noprefix (str / num)
  170.   ;; strip a filename of its path components.
  171.   (setq num (strlen str))
  172.   (while (and (< 0 num) (/= "/" (substr str num 1)) )
  173.          (setq num (1- num)) )
  174.   (substr str (1+ num)) )
  175.  
  176.  
  177.  
  178. (defun shortnumstr (num prec / fnum)
  179.   ;; create an integer string representation of a number if possible,
  180.   ;; else a real.
  181.   (cond ( (equal num (setq fnum (fix num)) 0.00000001)
  182.           (itoa fnum) )
  183.         ( (equal num (setq fnum (if (< 0 num)(1+ fnum)(1- fnum))) 0.00000001)
  184.           (itoa fnum) )
  185.         (T (rtos num 2 prec)) ) )
  186.  
  187.  
  188. (defun get_laystring (data contele / lay)
  189.   ;; return the name string of the layer used to display an entity.
  190.   ;; search blocklist for floatinglayer entities.
  191.   (setq lay (cdr (assoc 8 data)))
  192.   (if (and (= "0" lay) contele)
  193.       (get_laystring (entget (car contele)) (cdr contele))
  194.       lay) )
  195.  
  196.  
  197. (defun get_colstring (data contele / color)
  198.   ;; create a string out of the name of the displayed color of an entity.
  199.   ;; search blocklist for floating-color entities.
  200.   (if (or (null (setq color (cdr (assoc 62 data))))
  201.           (= -1 color) ) ; bylayer
  202.       (setq color (cdr (assoc 62 (tblsearch "LAYER"
  203.                                             (get_laystring data contele) )))) )
  204.   (if (= 0 color) ; byblock
  205.       (if contele
  206.           (get_colstring (entget (car contele))(cdr contele))
  207.           "7" )
  208.       (itoa color) ) )
  209.  
  210.  
  211.  
  212. (defun datestring (/ str mon)
  213.   ;; create a string out of the current date and time.
  214.   (setq str (rtos (GETVAR "cdate") 2 4)
  215.         mon '(("01"" Jan.")("02"" Feb.")("03"" Mar.")("04"" Apr.")
  216.               ("05"" May.")("06"" Jun.")("07"" Jul.")("08"" Aug.")
  217.               ("09"" Sep.")("10"" Oct.")("11"" Nov.")("12"" Dec.") ) )
  218.   (strcat (substr str 1 4)
  219.           (cadr (assoc (substr str 5 2) mon))
  220.           (substr str 7 3) " "
  221.           (substr str 10 2) ":"
  222.           (substr str 12) ) )
  223.  
  224.  
  225.  
  226. ;;; BLOCK TRANSFORMATIONS ******************************************************
  227.  
  228.  
  229. (defun trans_back (polylist blocks / xform matrix insp data )
  230.   ;; transform a list of pointlists from entity- or block-cs to wcs.
  231.   ;; blocks is a list containing -either the entity names of hierarchical blocks.  ;;                             -or a single entity name of a planar entity.
  232.   (setq blocks (get_backtrans blocks)
  233.         xform  (car blocks)
  234.         data   (caddr blocks)
  235.         blocks (cadr blocks)
  236.         matrix (car xform)
  237.         insp   (cadr xform) )
  238.   (if blocks
  239.       (setq polylist (trans_back polylist blocks)) )
  240.   (if (= "INSERT" (cdr (assoc 0 data)))
  241.       (if (or (/= 0.0 (cdr (assoc 70 data))) ; test for multiple-inserts.
  242.               (/= 0.0 (cdr (assoc 71 data))))
  243.           (setq polylist (shiftminsert polylist data )) )
  244.       (setq insp '(0.0 0.0 0.0)) )
  245.   (mapcar '(lambda (poly)
  246.                    (mapcar '(lambda (pt)
  247.                                     (transl-p (transf-p pt matrix) insp 1.0) )
  248.                            poly ) )
  249.           polylist ) )
  250.  
  251.  
  252.  
  253. (defun get_backtrans (bllist / data xform nxform txform)
  254.   ;; evaluate the transformation out of a hierarchy of blocks.
  255.   ;; stop if a multiple insert is encountered and include rest of blocklist.
  256.   (setq data (entget (car bllist))
  257.         xform (ent_xform data)
  258.         bllist (cdr bllist) )
  259.   (if (and bllist
  260.            (= 0.0 (cdr (assoc 70 data)))
  261.            (= 0.0 (cdr (assoc 71 data)) ))
  262.       (setq bllist (get_backtrans bllist)
  263.             nxform (car bllist)
  264.             data   (caddr bllist)
  265.             bllist (cadr bllist)
  266.             txform (list (matmul (car xform)(car nxform))
  267.                          (mapcar '+ (transf-p (cadr nxform) (car xform))
  268.                                  (cadr xform) ) ) )
  269.       (setq txform xform) )
  270.   (list txform bllist data) )
  271.  
  272.  
  273.  
  274. (defun shiftminsert (polylist data / npolylist
  275.                   xnum xxnum xdist xdir ynum yynum ydist ydir xfactor yfactor)
  276.   ;; calculate the offset of the parts of a multiple insert.
  277.   ;; make copies of polylist shifted apropriately.
  278.   (setq xdir  '(1.0 0.0 0.0)
  279.         xnum  (cdr (assoc 70 data))
  280.         xdist (/ (cdr (assoc 44 data))(cdr (assoc 41 data)))
  281.         ydir  '(0.0 1.0 0.0)
  282.         ynum  (cdr (assoc 71 data))
  283.         ydist (/ (cdr (assoc 45 data))(cdr (assoc 42 data))) )
  284.   (foreach poly polylist
  285.            (setq xxnum xnum )
  286.            (while (< 0 xxnum)
  287.                   (setq xxnum (1- xxnum)
  288.                         yynum ynum
  289.                         xfactor (* xxnum xdist) )
  290.                   (while (< 0 yynum)
  291.                          (setq yynum (1- yynum)
  292.                                yfactor (* yynum ydist) )
  293.                          (setq npolylist (cons (mapcar '(lambda (pt)
  294.                                            (transl-p (transl-p pt ydir yfactor)
  295.                                                      xdir
  296.                                                      xfactor) )
  297.                                                        poly)
  298.                                                npolylist) ) ) ) ) )
  299.  
  300.  
  301.  
  302.  
  303. (defun showpolylist (polylist)
  304.   ;; graphical debugging.
  305.   (mapcar '(lambda (ptl)
  306.                    (mapcar '(lambda (p1 p2)
  307.                                     (grdraw p1 p2 *col*) )
  308.                            ptl (shift ptl) ) )
  309.           polylist)
  310.   (setq *col* (max 10 (rem (+ 2 *col*) 250))) )
  311.  
  312.  
  313. ;;; ANALYSYS *********************************************************
  314.  
  315. (defun getetype (data / typ flag)
  316.   ;; extract the type of an entity.
  317.   (setq typ (cdr (assoc 0 data)) )
  318.   (if (= typ "POLYLINE")
  319.       (setq flag (cdr (assoc 70 data))
  320.             typ (cond ( (= 64 (logand flag 64))
  321.                          "PFACE" )
  322.                        ( (= 16 (logand flag 16))
  323.                          "PMESH" )
  324.                        ( (= 8 (logand flag 8))
  325.                          "3DPOLY" )
  326.                        ( (and (< 0.0 (cdr (assoc 40 data)))
  327.                               (valuablepoly "WPLINE") )
  328.                          "WPLINE")
  329.                        ( (and (= 1 (logand flag 1))
  330.                               (= 0 (logand flag 8))
  331.                               (valuablepoly "POLYGON") )
  332.                          "POLYGON" )
  333.                        ( T "PLINE") ) )
  334.       typ ) )
  335.  
  336.  
  337.  
  338.  
  339. ;;;-----------------------------------------------------------------------------
  340.  
  341. (defun pfacetopoly (data / ename xdata a b num face plist nodel pt)
  342.   ;; make a polygon list describing a polyface mesh depending on
  343.   ;; entity data 'data'
  344.   (setq ename (cdr (assoc -1 data))
  345.         data (entget ename '("MKVOL_LSP_01"))
  346.         xdata (cdadr (assoc -3 data))
  347.         b (entget (entnext (cdar data)))
  348.         nodel NIL
  349.         num 1 )
  350.   (while (= 64 (logand 64 (cdr (assoc 70 b))))
  351.          (setq nodel (cons (cons num (cdr (assoc 10 b ))) nodel )
  352.                b (entget (entnext (cdar b)))
  353.                num (1+ num)) )
  354.   (cond ( (and xdata (= "flat" (cdr (assoc 1000 xdata))))
  355.           (setq plist (list (reverse (mapcar 'cdr nodel)))) )
  356.         ( T
  357.          (while (/= "SEQEND" (cdr (assoc 0 b)))
  358.                 (foreach ptcode '(71 72 73 74)
  359.                          (if (/= 0 (setq pt (abs (cdr (assoc ptcode b)))))
  360.                              (setq face (cons (cdr (assoc pt nodel)) face)) ) )
  361.                 (setq plist (append plist
  362.                                     (planarize4 (elimstraights (reverse face))))
  363.                       face nil
  364.                       b (entget (entnext (cdar b))) ) ) ) )
  365.   plist )
  366.  
  367.  
  368.  
  369. ;;;-----------------------------------------------------------------------------
  370.  
  371. (defun linetopoly (data / dir dist p1 p2)
  372.   ;; make a polygon list describing a line depending on entity data 'data'
  373.   ;; if thickness > 0 else nil.
  374.   (cond ( (setq dist (cdr (assoc 39 data)))
  375.           (setq dir (cdr (assoc 210 data))
  376.                 p1  (cdr (assoc 10 data))
  377.                 p2  (cdr (assoc 11 data)) )
  378.           (if (< 0.0 (distance p1 p2))
  379.               (list (list p1 p2
  380.                           (transl-p p2 dir dist)
  381.                           (transl-p p1 dir dist) )) ) )
  382.         (T NIL) ) )
  383.  
  384.  
  385. ;;;-----------------------------------------------------------------------------
  386.  
  387. (defun plinetopoly (data typ segs / dist b plist p0 p1 p2 bulge flag uplist)
  388.   ;; make a polygon list describing a polyline depending on entity data 'data'
  389.   ;; the number of segments for arcs and the type:
  390.   ;; 1 - pline with thickness.
  391.   ;; 2 - closed pline as polygon.
  392.   ;; 3 - pline with constant width.
  393.   (setq flag (cdr (assoc 70 data))  ;polyline flags
  394.         dist (cdr (assoc 39 data))
  395.         b (entget (entnext (cdar data)))
  396.         p0 (cdr (assoc 10 b))
  397.         plist NIL )
  398.   (cond ( (and (= 0 (logand flag (+ 16 32 64))) ; 0 1 2 4 8 are allowed
  399.                (or (= 1 (logand flag 1)) dist ) )
  400.           (while (/= "SEQEND" (cdr (assoc 0 b)))
  401.                  (setq p1 (cdr (assoc 10 b ))
  402.                        plist (cons p1 plist )
  403.                        bulge (cdr (assoc 42 b))
  404.                        b (entget (entnext (cdar b))) )
  405.                  (if (and (/= 0.0 bulge)
  406.                           (or (/= "SEQEND" (cdr (assoc 0 b)))
  407.                               (= 1 (logand flag 1)) ) )
  408.                      (setq p2 (cdr (assoc 10 b ))
  409.                            p2 (if p2 p2 p0)
  410.                            plist (append (segment_arc
  411.                                           (bulgetoarc p1 p2 bulge segs))
  412.                                          plist ) ) ) )
  413.           (setq plist (reverse (elimstraights plist)))
  414.           (cond ( (< 1 (length plist))
  415.                   (if (= 3 typ)
  416.                       (setq plist (wideplist plist
  417.                                              (/ (cdr (assoc 40 data)) 2.0)
  418.                                              (= 1 (logand flag 1)))) )
  419.                   (cond ( (and dist (< 0.0 dist))
  420.                           (setq uplist (transup-l plist  dist)
  421.                                 plist (append (interfaces plist uplist
  422.                                                       (or (= 3 typ)
  423.                                                           (= 1 (logand flag 1))))
  424.                                               (if (or (= 3 typ)
  425.                                                       (and (= 2 typ)
  426.                                                            (= 1(logand flag 1))))
  427.                                                   (list plist (reverse uplist))
  428.                                                   nil ) ) )
  429.           )
  430.                 ( T (setq plist (list plist))) ) )
  431.           (T NIL) ) )
  432.         ( T NIL) )
  433.   (trans_back plist (list (cdar data))) ) ; end plinetolist
  434.  
  435.  
  436.  
  437. ;;;-----------------------------------------------------------------------------
  438.  
  439. (defun meshtopoly (data / a b flag m n mclose nclose plist pplist nplist  )
  440.   ;; make a polygon list describing a 3dpolygon mesh depending on
  441.   ;; entity data 'data'
  442.   (setq a data
  443.         b (entget (entnext (cdar a)))
  444.         flag (cdr (assoc 70 data))  ;polyline flags
  445.         m (cdr (assoc 71 data))
  446.         n (cdr (assoc 72 data))
  447.         mclose (= 1 (logand 1 flag ))
  448.         nclose (= 32 (logand 32 flag))
  449.         pplist NIL )
  450.   (cond ( (= 0 (logand flag (+ 2 4 8 64))) ; 0, 1, 16, 32 are allowed
  451.           (repeat m
  452.                   (setq plist nil)
  453.                   (repeat n
  454.                           (setq plist (cons(cdr (assoc 10 b )) plist)
  455.                                 b (entget (entnext (cdar b))) ) )
  456.                   (setq pplist (cons (reverse plist) pplist)) )
  457.           (mapcar '(lambda (pl1 pl2)
  458.                            (setq nplist (append (interfaces pl1 pl2 nclose)
  459.                                                 nplist)) )
  460.                   pplist (if mclose (shift pplist) (cdr pplist)) ) )
  461.         ( T NIL ) )
  462.   nplist )
  463.  
  464.  
  465. ;;;-----------------------------------------------------------------------------
  466.  
  467. (defun facetopoly (data)
  468.   ;; make a polygon list describing a 3dface depending on entity data 'data'
  469.   (planarize4 (elimstraights (mapcar '(lambda (code)
  470.                          (cdr (assoc code data)) )
  471.                 '(10 11 12 13) )) ) )
  472.  
  473.  
  474.  
  475. ;;;-----------------------------------------------------------------------------
  476.  
  477. (defun tracetopoly (data / dist plist uplist)
  478.   ;; make a polygon list describing a trace depending on entity data 'data'
  479.   (setq dist (cdr (assoc 39 data))
  480.         plist (elimstraights (mapcar '(lambda (code)
  481.                                               (cdr (assoc code data)) )
  482.                                      '(10 11 13 12) )) )
  483.   (cond ( (< 2 (length plist))
  484.           (if (and dist (/= 0.0 dist))
  485.               (setq uplist (transup-l plist  dist)
  486.                     plist (append (interfaces plist uplist T)
  487.                                   (list plist (reverse uplist))) )
  488.               (setq plist (list plist)) )
  489.           (trans_back plist (list (cdr (assoc -1 data)))) )
  490.         (T NIL) ) )
  491.  
  492.  
  493.    
  494.  
  495. ;;;-----------------------------------------------------------------------------
  496.  
  497. (defun arctopoly (data segments / center radius dist a1 a2 plist uplist)
  498.   ;; make a polygon list describing an arc depending on entity data 'data'
  499.   ;; and the number of segments.
  500.   (setq center (cdr (assoc 10 data))
  501.         radius (cdr (assoc 40 data))
  502.         dist (cdr (assoc 39 data))
  503.         a1 (cdr (assoc 50 data))
  504.         a2 (cdr (assoc 51 data))
  505.         plist (cons (polar center a1 radius)
  506.                 (append (segment_arc (list center radius a1 a2 segments))
  507.                             (list (polar center a2 radius)) ) ) )
  508.   (cond ( (and dist (/= 0.0 dist))
  509.           (setq uplist (transup-l plist  dist)
  510.                 plist (interfaces plist uplist NIL) )
  511.           (trans_back plist (list (cdr (assoc -1 data)))) )
  512.         (T NIL) ) )
  513.  
  514.  
  515. ;;;-----------------------------------------------------------------------------
  516.  
  517. (defun circletopoly (data segments / center radius dist plist uplist)
  518.   ;; make a polygon list describing a circle depending on entity data 'data'
  519.   ;; and the number of segments.
  520.   (setq center (cdr (assoc 10 data))
  521.         radius (cdr (assoc 40 data))
  522.         dist (cdr (assoc 39 data))
  523.         plist (cons (polar center 0.0 radius)
  524.                (segment_arc (list center radius 0.0 (* 2 pi) segments)) ) )
  525.   (if (and dist (/= 0.0 dist))
  526.       (setq uplist (transup-l plist  dist)
  527.             plist (append (interfaces plist uplist T)
  528.                           (list plist (reverse uplist))) )
  529.       (setq plist (list plist)) )
  530.   (trans_back plist (list (cdr (assoc -1 data)))) )
  531.  
  532.  
  533.  
  534. ;;; UTILITY **********************************************************
  535.  
  536. (defun transup-l (plist dist)
  537.   ;; move a list of points along z-axis.
  538.   (mapcar '(lambda (pt) (list (car pt)(cadr pt)(+ (caddr pt) dist)) ) plist) )
  539.  
  540.  
  541.  
  542. (defun interfaces (poly1 poly2 key / npolylist)
  543.   ;; return : list of planar polygons connecting input polys.
  544.   ;; key=T  : closed Polygon
  545.   ;; key=nil: open Polygon
  546.   ;; polygons should have equal length.
  547.   (mapcar '(lambda (p1 p2 p3 p4)
  548.                    (setq npolylist (append (planarize4 (elimstraights
  549.                                                         (list p1 p2 p3 p4)))
  550.                                            npolylist)) )
  551.           poly1 poly2
  552.           (if key (shift poly2) (cdr poly2))
  553.           (if key (shift poly1) (cdr poly1)) )
  554.   npolylist )   ; end interfaces
  555.  
  556.  
  557.  
  558. (defun planarize4 (ptlist / len)
  559.   ;; test a three or four sided polygon for planarity and make a list.
  560.   ;; if nonplanar, split in two while preserving orientation.
  561.   (cond ( (or (null ptlist) (> 3 (length ptlist))) NIL)
  562.         ( (= 3 (length ptlist)) (list ptlist))
  563.         ( (> 0.0000001 (abs (3det (vector (car ptlist)(cadr ptlist))
  564.                                      (vector (car ptlist)(caddr ptlist))
  565.                                      (vector (car ptlist)(cadddr ptlist)) )))
  566.           (list ptlist) )
  567.         ( T
  568.           (list (list (car ptlist)(cadr ptlist)(caddr ptlist))
  569.                 (cons (car ptlist)(cddr ptlist)) ) ) ) )
  570.  
  571.  
  572.  
  573. (defun elimstraights (pl / npl lastp)
  574.   ;; eliminate the points of a list that do not modify the shape of
  575.   ;; the polygon.
  576.   ;; eg.: - within straight segments.
  577.   ;;      - identical to previous.
  578.   ;;      - extending a segment the next one turns back on.
  579.   (setq npl (list (car pl))
  580.         lastp (last pl) )
  581.   (mapcar '(lambda (p1 p2)
  582.                    (if (and (not (equal p1 (car npl)))
  583.                             (or (< 0.0 (interang (vector (car npl) p1)
  584.                                                  (vector (car npl) p2)))
  585.                                 (equal lastp p1) ) )
  586.                        (setq npl (cons p1 npl)) ) )
  587.           (cdr pl) (cdr (shift pl)) )
  588.   (reverse npl) )
  589.  
  590.  
  591. (defun wideplist (pl hwidth closed / a1 a2 am adif doff rlist llist off1 off2)
  592.   ;; generates a polygon contouring the surface of pointlist 'pl' offset
  593.   ;; at both sides for the distance 'hw' (halfwidth).
  594.   (mapcar '(lambda (p1 p2 p3)
  595.                    (setq a1 (angle p1 p2)
  596.                          a2 (angle p2 p3)
  597.                          am (/ (- (+ a1 a2) pi) 2.0)
  598.                          adif (/ (- a2 a1) 2.0)
  599.                          doff (/ hwidth (cos adif))
  600.                          rlist (cons (polar p2 am doff) rlist)
  601.                          llist (cons (polar p2 am (- doff)) llist) ) )
  602.           (cons (last pl) pl) pl (shift pl)  )
  603.   (if closed
  604.       (append (reverse rlist) (list (last rlist)(last llist)) llist)
  605.       (setq off1 (offset pl hwidth)
  606.             off2 (offset (reverse pl) hwidth)
  607.             llist (cons (cadr off1) (cdr (reverse llist)))
  608.             llist (cons (car off2)(cdr (reverse llist)))
  609.             rlist (cons (cadr off2)(cdr rlist))
  610.             rlist (cons (car off1)(cdr (reverse rlist)))
  611.             rlist (append rlist llist) ) ) )
  612.  
  613.  
  614.  
  615. (defun offset (pl hw / ao)
  616.   ;; offset a pointlist to the right for a constant distance.
  617.   (setq ao (- (angle (car pl)(cadr pl)) (/ pi 2.0)))
  618.   (list (polar (car pl) ao hw)
  619.         (polar (car pl) ao (- hw)) ) )
  620.  
  621.  
  622.  
  623. (defun segment_arc (arc / flag ai num astep acur plist)
  624.   ;; generates the inner segment points of an arc.
  625.   ;; starting and end point are not included.
  626.   ;; 'arc' '(centerpoint radius starting_angle ending_angle num_of_segs)'.
  627.   ;; the arc goes couterclockwise if 'num_of_segs' is positive.
  628.   (setq ai (- (cadddr arc)(caddr arc)))
  629.   (if (< ai 0) (setq ai (+ (* 2.0 PI) ai)))
  630.   (setq num (fix (1+ (/ ai (/ (* 2 pi) (abs (last arc))))))
  631.         astep (/ ai (1- (max 3 num)))
  632.         acur (caddr arc) )
  633.   (repeat (- num 2)
  634.           (setq acur (+ acur astep)
  635.                 plist (cons (polar (car arc) acur (cadr arc)) plist) ) )
  636.   (if (< 0 (last arc))
  637.       (reverse plist)
  638.        plist ) )
  639.  
  640.  
  641.  
  642. (defun bulgetoarc (p1 p2 bulge segs / x1 y1 x2 y2 cotbce a1 a2 center radius)
  643.   ;; make an arc description out of the AutoCad bulge form.
  644.   ;; 'arc' '(centerpoint radius starting_angle ending_angle num_of_segs)'.
  645.   (setq x1 (car p1) y1 (cadr p1)
  646.         x2 (car p2) y2 (cadr p2)
  647.         cotbce (/ (- (/ 1.0 bulge) bulge) 2.0)
  648.         center (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
  649.                      (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
  650.                      (caddr p1) )
  651.         radius (distance p1 center)
  652.         a1 (atan (- y1 (cadr center)) (- x1 (car center)))
  653.         a2 (atan (- y2 (cadr center)) (- x2 (car center))) )
  654.   (if (< a1 0.0) (setq a1 (+ a1 pi pi)))
  655.   (if (< a2 0.0) (setq a2 (+ a2 pi pi)))
  656.   (if (< bulge 0.0)
  657.       (list center radius a2 a1 segs)
  658.       (list center radius a1 a2 (- segs)) ) )
  659.  
  660.  
  661.  
  662. (defun shift (alist)
  663.   (append (cdr alist) (list (car alist))) )
  664.  
  665.  
  666. ;;; end of esample.lsp ********************************************************
  667.